home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Whiteline: delta
/
whiteline CD Series - delta.iso
/
progtool
/
modula2
/
m2d2
/
funny
/
funny.mod
< prev
next >
Wrap
Text File
|
1995-11-25
|
17KB
|
492 lines
MODULE Funny;
(*
* In diesem Accessory wird einmal gezeigt, wie einfach saubere
* GEM-Programmierung sein kann. In diesem Beispiel geht es um die Verwendung
* der CopyRaster-Funktion des VDI.
*
* Außerdem ist das Accessory eine nette kleine Spielerei, mit der auf
* dem Monitor interessante und effektvolle Bilder erzeugt werden können.
*
* (Tip: man spiele einmal mit mehreren Fenstern und dem Funny-Window als
* unterem aber sichtbarem Fenster)
*
* Die Idee ist übrigens nicht auf meinem Mist gewachsen, denn ich habe
* einmal ein ähnliches, aber lange nicht so schönes, Programm auf einem
* Rechner einer fast unbekannten Firma (die Gründer waren wohl einmal
* Apfelpflücker), laufen sehen.
*
* Das Programm wurde mit dem TDI-Modula-2/ST Release 3.01a erstellt.
* Bibliotheken, die nicht zum Standardlieferumfang von TDI gehören,
* wurden von *PSB erstellt und werden nicht mitgeliefert.
* Die Funktion der entsprechenden Routinen wird an geeigneter Stelle im
* Quelltext beschrienen.
*
* Erstellt an einem verregneten Nachmittag im Herbst '91
*
* (c) '91 Thomas Birke, *PSB
*
* Dank an all die fleißigen Teepflücker in Ceylon, Indien und Ostfriesland.
*
* *Pentagramm Software Braunschweig Thomas Birke
* Billrothstr. 31
* 3300 Braunschweig
*)
(*$S-,$T-,$A+*)
FROM SYSTEM IMPORT ADR, NULL;
FROM GEMAES IMPORT ApplInitialise, MenuRegister, EventMultiple,
WindowCalc, WindowCreate, WindowOpen,
WindowClose, WindowDelete, WindowUpdate,
WindowGet, WindowSet, GrafHandle,
FormDo, FormCenter, FormDialogue,
ObjectDraw, ResourceGetAddr;
(* man suche in den jeweiligen AES-Bibliotheken *)
FROM GEMAESbase IMPORT AESGlobal, WindowRedraw, WindowTopped,
WindowClosed, WindowFulled, WindowArrowed,
WindowHorizSlided, WindowVertSlided,
WindowSized, WindowMoved, WindowNewTop,
AccessoryOpen, AccessoryClose, WindowName,
WindowInfo, WorkXYWH, CurrXYWH,
PrevXYWH, FullXYWH, WindowHorizSlide,
WindowVertSlide, Top,
FirstXYWH, NextXYWH, NewDesk,
HorizSliderSize, VertSliderSize,
WindowScreen, BeginUpdate, EndUpdate,
FormStart, FormGrow, FormShrink,
FormFinish, RTree, Name,
Closer, Fuller, Mover,
Sizer, UpArrow, DownArrow,
VertSlide, LeftArrow, RightArrow,
HorizSlide, MesageEvent, TimerEvent,
Object, osSELECTED;
FROM GEMVDI IMPORT MFDBType, CopyRasterOpaque,
OpenVirtualWorkstation,
CloseVirtualWorkstation,
ExtendedInquire,
SetClipping, SampleMouseButton,
HideCursor, ShowCursor;
(* siehe GEMAES, hier allerdings VDI *)
FROM GEMVDIbase IMPORT PxyArrayType, BigPxyArrayType,
VDIWorkInType, VDIWorkOutType;
FROM Arithmetic IMPORT RCIntersect, Imax, Imin;
(* Imax und Imin brauchen wohl kaum erklärt zu
* werden, RCIntersect ist da schon interessanter
* C-Programmierer werden diese Funktion kennen.
* RCIntersect prüft, ob sich zwei Rechtecke
* schneiden, und gibt den entsprechenden
* Wahrheitswert zurück. Zusätzlich werden in den
* Koordinaten des ersten Rechtecks (VAR-Parameter)
* die Koordinaten des Schnittrechtecks geliefert.
*)
FROM XGEMDOS IMPORT Alloc, Free; (* oder auch GEMDOS *)
FROM FunnyRSC IMPORT RelocateRSC, Alert, Function;
(* Da die Resource bei Accessories nicht
* nachgeladen werden sollte, wird sie in den
* Programmcode eingebunden.
*)
CONST NoWindow = -1;
Desktop = 0;
SourceToDest = 3;
Message = 4;
TYPE RectMFDB = RECORD
OffsetToWordBoundary,
x, y,
w, h : INTEGER;
MFDB : MFDBType
END;
VAR ApplID,
MenuID,
VDIhandle,
WindowHandle,
occuredEvents : INTEGER;
MessageBuffer : ARRAY [ 0..7 ] OF INTEGER;
MouseX, MouseY,
MouseButtonState,
ShiftKeyState,
PressedKey,
MouseClicks : INTEGER;
ScreenMFDB : MFDBType;
LastX, LastY,
DesktopX,
DesktopY,
DesktopWidth,
DesktopHeight,
DesktopXrechts,
DesktopYunten,
WindowX,
WindowY,
WindowWidth,
WindowHeight : INTEGER;
WindowTitle : ARRAY [ 0..15 ] OF CHAR;
Pxy : BigPxyArrayType;
Rectangle : RectMFDB;
DialogBox : POINTER TO ARRAY [ 0..Function ] OF Object;
Planes : CARDINAL;
PROCEDURE Open;
(* Der Eintrag des Accessories in der Menüzeile wurde gewählt *)
VAR WorkIn : VDIWorkInType;
WorkOut : VDIWorkOutType;
i : INTEGER;
lc : LONGCARD;
BEGIN
IF WindowHandle = NoWindow (* wenn noch kein Fenster offen ist : *)
THEN
FOR i := 0 TO 9 DO
WorkIn [ i ] := 1 (* beim VDI anmelden *)
END;
WorkIn [ 10 ] := 2;
VDIhandle := GrafHandle ( i, i, i, i );
OpenVirtualWorkstation ( WorkIn, VDIhandle, WorkOut );
Planes := AESGlobal.apNPlanes;
WindowGet ( 0, WorkXYWH,
DesktopX, DesktopY, DesktopWidth, DesktopHeight );
(* rechte untere Ecke des Desktops bestimmen *)
DesktopXrechts := DesktopX + DesktopWidth;
DesktopYunten := DesktopY + DesktopHeight;
WindowHandle := WindowCreate ( HorizSlide + RightArrow + LeftArrow
+ VertSlide + DownArrow + UpArrow
+ Sizer + Mover + Fuller + Closer + Name,
DesktopX, DesktopY,
DesktopWidth, DesktopHeight );
IF WindowHandle = NoWindow
THEN CloseVirtualWorkstation ( VDIhandle );
RETURN
END;
lc := LONGCARD ( ADR ( WindowTitle ) );
WindowSet ( WindowHandle, WindowName,
INTEGER ( lc DIV 65536 ), INTEGER ( lc MOD 65536 ),
0, 0 );
WindowSet ( WindowHandle, WindowHorizSlide, 500, 0, 0, 0 );
WindowSet ( WindowHandle, WindowVertSlide, 500, 0, 0, 0 );
WindowSet ( WindowHandle, HorizSliderSize, 333, 0, 0, 0 );
WindowSet ( WindowHandle, VertSliderSize, 333, 0, 0, 0 );
WindowOpen ( WindowHandle,
WindowX, WindowY, WindowWidth, WindowHeight )
ELSE TopWindow (* Falls schon ein Fenster geöffnet war, *)
END (* dieses zum obersten Fenster machen *)
END Open;
PROCEDURE Close;
(* Der Schließer des Fensters wurde vom Benutzer angeklickt *)
BEGIN
WindowClose ( WindowHandle );
DeleteWindow
END Close;
PROCEDURE DeleteWindow;
(* Das Fenster ist bereits geschlossen, aber noch vorhanden. Es wird *)
(* gelöscht, und das VDI-Handle wird abgegeben. *)
BEGIN
IF WindowHandle # NoWindow
THEN WindowDelete ( WindowHandle );
WindowHandle := NoWindow;
CloseVirtualWorkstation ( VDIhandle )
END
END DeleteWindow;
PROCEDURE TopWindow;
(* Das Fenster wird zum obersten Fenster auf dem Desktop *)
BEGIN
WindowSet ( WindowHandle, Top, 0, 0, 0, 0 )
END TopWindow;
PROCEDURE Full;
(* Der 'Fuller' des Fensters wurde angeklickt. *)
VAR X, Y, W, H,
x, y, w, h : INTEGER;
BEGIN
WindowGet ( WindowHandle, FullXYWH, X, Y, W, H );
WindowGet ( WindowHandle, CurrXYWH, x, y, w, h );
IF ( x = X ) AND ( y = Y ) AND ( w = W ) AND ( h = H )
THEN WindowGet ( WindowHandle, PrevXYWH, X, Y, W, H )
END;
WindowSet ( WindowHandle, CurrXYWH, X, Y, W, H )
END Full;
PROCEDURE Size;
(* Das Fenster wurde in seiner Größe geändert *)
BEGIN
WindowX := MessageBuffer [ 4 ];
WindowY := MessageBuffer [ 5 ];
WindowWidth := MessageBuffer [ 6 ];
WindowHeight := MessageBuffer [ 7 ];
WindowSet ( WindowHandle, CurrXYWH,
WindowX, WindowY, WindowWidth, WindowHeight )
END Size;
PROCEDURE Arrow ( direction : INTEGER );
(* Im Fenster wurde einer der Pfeile oder der grauen Balken betätigt *)
BEGIN
CASE direction OF
0 : NotImplemented ( '"Seite aufwärts blättern"' ) |
1 : NotImplemented ( '"Seite abwärts blättern"' ) |
2 : NotImplemented ( '"Zeile aufwärts blättern"' ) |
3 : NotImplemented ( '"Zeile abwärts blättern"' ) |
4 : NotImplemented ( '"Seite nach links blättern"' ) |
5 : NotImplemented ( '"Seite nach rechts blättern"' ) |
6 : NotImplemented ( '"Spalte nach links blättern"' ) |
7 : NotImplemented ( '"Spalte nach rechts blättern"' ) |
ELSE
END
END Arrow;
PROCEDURE Redraw;
(* Ein Neuzeichnen des Fensterinhaltes ist erforderlich *)
VAR X, Y, W, H,
WorkX,
WorkY,
WorkWidth,
WorkHeight : INTEGER;
lc : LONGCARD;
BEGIN
WindowGet ( WindowHandle, WorkXYWH,
WorkX, WorkY, WorkWidth, WorkHeight );
MouseX := Imin ( MouseX, DesktopXrechts - WorkWidth );
MouseY := Imin ( MouseY, DesktopYunten - WorkHeight );
IF ( MouseX = LastX ) AND ( MouseY = LastY ) THEN RETURN END;
LastX := MouseX;
LastY := MouseY;
WindowUpdate ( BeginUpdate );
HideCursor ( VDIhandle );
SaveRectangle ( MouseX, MouseY, WorkWidth, WorkHeight );
IF Rectangle.MFDB.pointer # NULL
THEN
WindowGet ( WindowHandle, FirstXYWH, X, Y, W, H );
WHILE ( W # 0 ) OR ( H # 0 ) DO
IF RCIntersect ( X, Y, W, H,
WorkX, WorkY, WorkWidth, WorkHeight ) AND
RCIntersect ( X, Y, W, H,
DesktopX, DesktopY, DesktopWidth, DesktopHeight )
THEN
WITH Rectangle DO
Pxy [ 0 ] := OffsetToWordBoundary + X - WorkX;
Pxy [ 1 ] := Y - WorkY;
Pxy [ 2 ] := Pxy [ 0 ] + W - 1;
Pxy [ 3 ] := Pxy [ 1 ] + H - 1;
Pxy [ 4 ] := X;
Pxy [ 5 ] := Y;
Pxy [ 6 ] := X + W - 1;
Pxy [ 7 ] := Y + H - 1;
CopyRasterOpaque ( VDIhandle, SourceToDest, Pxy,
ADR ( MFDB ), ADR ( ScreenMFDB ) )
END;
END;
WindowGet ( WindowHandle, NextXYWH, X, Y, W, H )
END;
WITH Rectangle.MFDB DO
IF Free ( pointer ) THEN END;
pointer := NULL
END;
END;
ShowCursor ( VDIhandle, 0 );
WindowUpdate ( EndUpdate )
END Redraw;
PROCEDURE SaveRectangle ( bx, by, bw, bh : INTEGER );
(* Der Bildschirm-Ausschnitt mit den Koordinaten (bx,by,bw,bh) wird *)
(* gesichert *)
VAR Pxy : BigPxyArrayType;
BEGIN
WITH Rectangle DO
WITH MFDB DO
x := bx;
y := by;
w := bw;
h := bh;
OffsetToWordBoundary := x MOD 16;
width := bw;
height := bh;
widthW := ( bw DIV 16 ) + 2;
format := 0;
planes := Planes;
Alloc ( LONGCARD ( widthW ) * LONGCARD ( bh )
* LONGCARD ( Planes ) * 2, pointer );
IF pointer = NULL THEN RETURN END
END;
Pxy [ 0 ] := bx;
Pxy [ 1 ] := by;
Pxy [ 2 ] := bx + bw - 1;
Pxy [ 3 ] := by + bh - 1;
Pxy [ 4 ] := OffsetToWordBoundary;
Pxy [ 5 ] := 0;
Pxy [ 6 ] := OffsetToWordBoundary + bw - 1;
Pxy [ 7 ] := bh - 1;
CopyRasterOpaque ( VDIhandle, SourceToDest, Pxy,
ADR ( ScreenMFDB ), ADR ( MFDB ) )
END
END SaveRectangle;
PROCEDURE Msg;
(* Vom System kam eine Message, die nun bearbeitet werden muß *)
BEGIN
CASE MessageBuffer [ 0 ] OF
AccessoryOpen : Open |
AccessoryClose : DeleteWindow |
WindowRedraw : DEC ( LastX );
Redraw |
WindowTopped : TopWindow |
WindowClosed : Close |
WindowFulled : Full |
WindowSized,
WindowMoved : Size |
WindowArrowed : Arrow ( MessageBuffer [ 4 ] ) |
WindowHorizSlided : NotImplemented ( '"horizontal scrollen"' ) |
WindowVertSlided : NotImplemented ( '"vertikal scrollen"' ) |
ELSE
END
END Msg;
PROCEDURE NotImplemented ( VAR s : ARRAY OF CHAR );
(* bringt eine Dialogbox mit entsprechender Meldung auf den *)
(* Bildschirm *)
VAR returnButton,
x, y, w, h : INTEGER;
BEGIN
IF MouseButtonState = 0 (* nur wenn keine Maustaste gedrückt ist *)
THEN
DialogBox^[ Function ].obSpec := ADR ( s ); (* Inh. setzen *)
FormCenter ( DialogBox, x, y, w, h );
FormDialogue ( FormStart, 0, 0, 0, 0, x, y, w, h );
FormDialogue ( FormGrow, 0, 0, 0, 0, x, y, w, h );
ObjectDraw ( DialogBox, 0, 8, x, y, w, h );
returnButton := FormDo ( DialogBox, 0 );
EXCL ( DialogBox^[ returnButton ].obState, osSELECTED );
FormDialogue ( FormFinish, 0, 0, 0, 0, x, y, w, h );
FormDialogue ( FormShrink, 0, 0, 0, 0, x, y, w, h )
END
END NotImplemented;
BEGIN
ApplID := ApplInitialise ();
MenuID := MenuRegister ( ApplID, ' Funny-Window' );
RelocateRSC;
ResourceGetAddr ( RTree, Alert, DialogBox );
ScreenMFDB.pointer := NULL;
WindowHandle := NoWindow;
WindowTitle := ' Funny ';
WindowX := 48;
WindowY := 48;
WindowWidth := 133;
WindowHeight := 133;
LOOP
occuredEvents := EventMultiple ( MesageEvent + TimerEvent, 0, 0, 0,
0, 0, 0, 0, 0,
0, 0, 0, 0, 0,
ADR ( MessageBuffer ),
20, 0,
MouseX, MouseY, MouseButtonState,
ShiftKeyState, PressedKey,
MouseClicks );
IF Message IN BITSET ( occuredEvents ) THEN Msg END;
IF WindowHandle # NoWindow
THEN SampleMouseButton ( VDIhandle, MouseButtonState, MouseX, MouseY );
Redraw
END
END
END Funny.